home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 September (IDG) / Sep99.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / menus.tcl < prev    next >
Encoding:
Text File  |  1999-04-16  |  26.3 KB  |  937 lines  |  [TEXT/ALFA]
  1. # Menu creation procs
  2.     
  3. namespace eval menu {}
  4. namespace eval global {}
  5. namespace eval file {}
  6.  
  7. proc menu::buildBasic {} {
  8.     global winMenu HOME
  9.     # These are built on the fly
  10.     Menu -n File -p menu::generalProc {}
  11.     Menu -n Edit -p menu::generalProc {}
  12.     Menu -n Text -p menu::generalProc {}
  13.     Menu -n Search {}
  14.     Menu -n Utils {}
  15.     Menu -n Config {}
  16.     Menu -n $winMenu {}
  17.     
  18.     insertMenu "File"
  19.     insertMenu "Edit"
  20.     insertMenu "Text"
  21.     insertMenu "Search"
  22.     insertMenu "Utils"
  23.     insertMenu "Config"
  24.     insertMenu $winMenu
  25.     
  26.     if {![catch {glob [file join $HOME Help *]} files]} {
  27.     set men { "Alpha Manual" "Quick Start" "Alpha Commands" "Tcl Commands" \
  28.       "(-" "Readme" "Changes" \
  29.       "Extending Alpha" "Bug Reports and Debugging" "(-" }
  30.     foreach f $men {
  31.         if {$f != "(-" && ![file exists [file join ${HOME} Help $f]]} {
  32.         set men [lremove $men $f]
  33.         }
  34.     }
  35.     set ignore "" 
  36.     foreach f [lsort $files] {
  37.         set f [file tail $f]
  38.         if {[lsearch $men $f] < 0 && [lsearch $ignore $f] < 0} {
  39.         lappend men $f
  40.         }
  41.     }
  42.     regsub -all {\(-[ \t\r\n]+\(-} $men {\(-} men
  43.     foreach f $men {
  44.         addHelpMenu $f
  45.     }
  46.     }
  47.     
  48. }
  49.  
  50. proc menu::buildwinMenu {} {
  51.     global winMenu winNameToNum
  52.     set ma {
  53.     "//<Szoom"
  54.     "//<S<I<OdefaultSize"
  55.     "<S/;chooseAWindow"
  56.     "/I<Biconify"
  57.     {Menu -n arrange -p menu::winTileProc {
  58.         "/Jvertically^1"
  59.         "/J<O<Ihorizontally^2"
  60.         "/J<B<OunequalVert^6"
  61.         "/J<B<I<OunequalHor^5"
  62.         "(-"
  63.         {Menu -n other {
  64.         {bufferOtherWindow}
  65.         {iconify}
  66.         {nextWin}
  67.         {nextWindow}
  68.         {prevWindow}
  69.         {shrinkFull}
  70.         {shrinkHigh}
  71.         {shrinkLeft}
  72.         {shrinkLow}
  73.         {shrinkRight}
  74.         {defaultSize}
  75.         {swapWithNext}
  76.         {zoom}
  77.         }}}
  78.     }
  79.     "(-"
  80.     "/msplitWindow"
  81.     "/otoggleScrollbar"
  82.     "(-"
  83.     }
  84.     # We may be reloading, so add whatever windows we have
  85.     if {[info exists winNameToNum]} {
  86.     set nms [array names winNameToNum]
  87.     foreach name $nms {
  88.         set item [file tail $name]
  89.         set num $winNameToNum($name)
  90.         if {$num < 10}     {
  91.         lappend ma /$num${item}
  92.         } else {
  93.         lappend ma ${item}
  94.         }
  95.     }
  96.     }
  97.     return [list "build" $ma menu::winProc "" $winMenu]
  98. }
  99.  
  100. proc global::listAllBindings {} {
  101.     new -n {* All Key Bindings *} -m Tcl -info [bindingList]
  102. }
  103.  
  104. proc global::listGlobalBindings {} {
  105.     global mode::features
  106.     set text ""
  107.     set tmp [lsort -ignore [array names mode::features]]
  108.     foreach b [split [bindingList] "\r"] {
  109.     set lst [lindex [split $b  " "] end]
  110.     if {[lsearch $tmp $lst] < 0} {
  111.         append text "$b\r"
  112.     }
  113.     }
  114.     new -n {* Global Key Bindings *} -m Tcl -info $text
  115. }
  116.  
  117. proc global::listPackages {} {
  118.     global index::feature
  119.     cache::read index::maintainer
  120.     foreach i [array names index::maintainer] {
  121.     set j [lindex [set index::maintainer($i)] 1]
  122.     set au($i) "[lindex $j 0], [lindex $j 1]"
  123.     }
  124.     new -n {* Installed Packages *} -m Text
  125.     append t "Currently installed packages\r\r"
  126.     append t "columns are: name, version, and maintainer\r"
  127.     append t "\r\rMenus:"
  128.     insertText $t ; set t ""
  129.     foreach p [lsort -ignore [array names index::feature]] {
  130.     set v [alpha::package versions $p]
  131.     if {[lindex $v 0] == "mode"} {
  132.         set v "for [lindex $v 1] mode"
  133.     }
  134.     switch -- [lindex [set index::feature($p)] 2] {
  135.         "1" {
  136.         append tm "\r[format {  %-25s %-10s  } $p $v]"
  137.         if {[info exists au($p)]} {append tm $au($p)}
  138.         }
  139.         "0" {
  140.         append tp "\r[format {%s %-25s %-10s  } [package::active $p {• { }}] $p $v]"
  141.         if {[info exists au($p)]} {append tp $au($p)}
  142.         }
  143.         "-1" {
  144.         append ta "\r[format {  %-25s %-10s  } $p $v]"
  145.         if {[info exists au($p)]} {append ta $au($p)}
  146.         }
  147.     }
  148.     }
  149.     if {[info exists tm]} {insertText $tm ; unset tm}
  150.     insertText "\r\rFeatures ('•' = active):"
  151.     if {[info exists tp]} {insertText $tp ; unset tp}
  152.     insertText "\r\rAuto-loading features:"
  153.     if {[info exists ta]} {insertText $ta ; unset ta}
  154.     append t "\r\rModes:"
  155.     insertText $t ; set t ""
  156.     foreach p [lsort -ignore [alpha::package names -mode]] {
  157.     set v [alpha::package versions $p]
  158.     if {[lindex $v 0] == "mode"} {
  159.         set v "for [lindex $v 1] mode"
  160.     }
  161.     append t "\r[format {  %-8s %-10s  } $p $v]"
  162.     if {[info exists au($p)]} {append t $au($p)}
  163.     }
  164.     insertText $t ; set t ""
  165.     winReadOnly
  166.     shrinkWindow
  167. }
  168.  
  169. proc global::listFunctions {} {
  170.     global win::Modes
  171.     new -n {* Functions *} -m Tcl -info \
  172.       "===\r\tCommand-double-click on a function to see its definition\r===\r\r[join [lsort -ignore [info commands]] \r]\r"
  173. }
  174.  
  175. proc global::menusAndFeatures {} {
  176.     global global::features mode::features mode
  177.     
  178.     set newGlobals [dialog::pickMenusAndFeatures global]
  179.     set offon [package::onOrOff $newGlobals $mode 1]
  180.  
  181.     set global::features $newGlobals
  182.     # remove removed menus
  183.     foreach m [lindex $offon 0] {
  184.     package::deactivate $m
  185.     }
  186.     foreach m [lindex $offon 1] {
  187.     package::activate $m
  188.     }
  189. }
  190.  
  191. proc global::insertAllMenus {} {
  192.     global global::features index::feature
  193. #    foreach m ${global::features} {
  194. #    if {[lindex [set index::feature($m)] 2] == 0} {
  195. #        package::activate $m
  196. #    }
  197. #    }
  198.     foreach m ${global::features} {
  199.     if {[lindex [set index::feature($m)] 2] == 1} {
  200.         package::activate $m
  201.     }
  202.     }
  203. }
  204.  
  205. proc global::rebuildPackageIndices {} {
  206.     if {[dialog::yesno "You must quit Alpha immediately after rebuilding. \
  207.       Proceed?"]} {
  208.     alpha::rebuildPackageIndices
  209.     }
  210. }
  211.  
  212. ## 
  213.  # -------------------------------------------------------------------------
  214.  # 
  215.  # "menu::buildProc" --
  216.  # 
  217.  #  Register a procedure to be the 'build proc' for a given menu.  This
  218.  #  procedure can do one of two things:
  219.  #  
  220.  #  i) build the entire menu, including evaluating the 'menu ...' command.
  221.  #  In this case the build proc should return anything which doesn't
  222.  #  begin 'build ...'
  223.  #  
  224.  #  ii) build up part of the menu, and then allow pre-registered menu
  225.  #  insertions/replacements to take-effect.  In this case the procedure
  226.  #  should return a list of the items (listed by index):
  227.  #  
  228.  #  0: "build"
  229.  #  1: list-of-items-in-the-menu
  230.  #  2: list of other flags.  If the list doesn't contain '-p', we use
  231.  #  the standard menu::generalProc procedure.  If it does contain '-p'
  232.  #  general prmenu procedure to call when an item is selected.  
  233.  #  If nothing is given,
  234.  #  or if '-1' is given, then we don't have a procedure.  If "" is given,
  235.  #  we use the standard 'menu::generalProc' procedure.  Else we use the
  236.  #  given procedure.
  237.  #  3: list of submenus which need building.
  238.  #  4: over-ride for the name of the menu.
  239.  #  
  240.  #  You must register the build-proc before attempting to build the menu.
  241.  #  Once registered, any call of 'menu::buildSome name' will build your
  242.  #  menu.
  243.  # -------------------------------------------------------------------------
  244.  ##
  245. proc menu::buildProc {name proc} {
  246.     global menu::build_procs
  247.     set menu::build_procs($name) $proc
  248. }
  249.  
  250. ## 
  251.  # -------------------------------------------------------------------------
  252.  # 
  253.  # "menu::insert" --
  254.  # 
  255.  #  name, type, where, then list of items.  type = 'items' 'submenu'
  256.  #  
  257.  #  Add given items to a given menu, provided they are not already there.
  258.  #  Rebuild that menu if necessary.
  259.  #  
  260.  #  There are also procs 'menu::removeFrom' which does the opposite of
  261.  #  this one, and 'menu::replaceWith' which replaces a given menu item
  262.  #  with others.
  263.  # -------------------------------------------------------------------------
  264.  ##
  265. proc menu::insert {name args} {
  266.     if {[llength $args] < 3} { error "Too few args to menu::insert" }
  267.     global menu::additions alpha::noMenusYet
  268.     if {[info exists menu::additions($name)]} {
  269.     set a [set menu::additions($name)]
  270.     if {[lsearch -exact $a $args] != -1} { 
  271.         return 
  272.     }
  273.     # check if it's there but in a different place; we over-ride
  274.     set dblchk [lreplace $args 1 1 "*"]
  275.     if {[set i [lsearch -glob $a $dblchk]] == -1} {
  276.         unset i
  277.     }
  278.     }
  279.     if {[info exists i]} {
  280.     set menu::additions($name) [lreplace $a $i $i $args]
  281.     } else {
  282.     lappend menu::additions($name) $args
  283.     }
  284.     if {![info exists alpha::noMenusYet]} {
  285.     # we were called after start-up; build the menu now
  286.     menu::buildSome $name
  287.     }
  288. }
  289.  
  290. proc menu::uninsert {name args} {
  291.     global menu::additions alpha::noMenusYet
  292.     set a [set menu::additions($name)]
  293.     if {[set idx [lsearch -exact $a $args]] == -1} { 
  294.     return 
  295.     }
  296.     set menu::additions($name) [lreplace $a $idx $idx]
  297.     if {![info exists alpha::noMenusYet]} {
  298.     # we were called after start-up; build the menu now
  299.     menu::buildSome $name
  300.     }
  301. }
  302.  
  303. proc alpha::buildMainMenus {} {
  304.     menu::buildProc internetUpdates package::makeUpdateMenu
  305.     menu::buildProc packages menu::packagesBuild
  306.     menu::buildProc mode menu::modeBuild
  307.     menu::buildProc winMenu menu::buildwinMenu
  308.     menu::buildProc preferences menu::preferencesBuild
  309.     uplevel #0 {
  310.     source [file join $HOME Tcl SystemCode alphaMenus.tcl]
  311.     menu::buildSome "File" "Edit" "Text" "Search" "Utils" "Config" "winMenu"
  312.     }
  313. }
  314.  
  315. ## 
  316.  # -------------------------------------------------------------------------
  317.  # 
  318.  # "menu::buildSome" --
  319.  # 
  320.  #  Important procedure which builds all known/registered menus from a
  321.  #  number of pieces.  It allows the inclusion of menus pieces registered
  322.  #  with the menu::insert procedure, which allows you easily to add items
  323.  #  (including dynamic and hierarchial) to any of Alpha's menus.
  324.  # 
  325.  # Results:
  326.  #  Various menus are (re)built
  327.  # 
  328.  # Side effects:
  329.  #  Items added to those menus with 'addMenuItem' will vanish.
  330.  # 
  331.  # --Version--Author------------------Changes-------------------------------
  332.  #    1.0     <darley@fas.harvard.edu> original
  333.  #    2.0     <darley@fas.harvard.edu> more compact, more like tk
  334.  # -------------------------------------------------------------------------
  335.  ##
  336. proc menu::buildSome {args} {
  337.     set msubs {}
  338.     foreach token $args {
  339.     eval lappend msubs [menu::buildOne $token]
  340.     }
  341.     # build sub-menus of those built
  342.     if {[llength $msubs]} {eval menu::buildSome $msubs}
  343. }
  344.  
  345. proc menu::buildOne {args} {
  346.     global menu::additions menu::build_procs alpha::noMenusYet \
  347.       menu::items
  348.     set token [lindex $args 0] ; set args [lrange $args 1 end]
  349.     if {[set len [llength $args]] > 0 || [info exists menu::build_procs($token)]} {
  350.     if {$len > 0} {
  351.         set res $args
  352.     } else {
  353.         if {[catch "[set menu::build_procs($token)]" res]} {
  354.         alpha::reportError "The menu $token had a problem starting up ; $res"
  355.         }
  356.     }
  357.     switch -- [lindex $res 0] {
  358.         "build" {
  359.         set ma [lindex $res 1]
  360.         if {[llength $res] > 2} {
  361.             set theotherflags [lrange [lindex $res 2] 1 end]
  362.             if {[lindex [lindex $res 2] 0] != -1} {
  363.             set mproc [lindex [lindex $res 2] 0]
  364.             }
  365.             if {[lindex $res 3] != ""} {
  366.             eval lappend msubs [lindex $res 3]
  367.             }
  368.             if {[lindex $res 4] != ""} { set name [lindex $res 4] }
  369.         }
  370.         } "menu" - "Menu" {
  371.         eval $res
  372.         return ""
  373.         } default {
  374.         return ""
  375.         }
  376.     }
  377.     } else {
  378.     set ma ""
  379.     if {[info exists menu::items($token)]} {
  380.         set ma [set menu::items($token)]
  381.         global menu::proc menu::which_subs menu::otherflags
  382.         if {[info exists menu::proc($token)]} {
  383.         set mproc [set menu::proc($token)]
  384.         }
  385.         if {[info exists menu::which_subs($token)]} {
  386.         eval lappend msubs [set menu::which_subs($token)]
  387.         }
  388.         if {[info exists menu::otherflags($token)]} {
  389.         set theotherflags [set menu::otherflags($token)]
  390.         }
  391.     }
  392.     }
  393.  
  394.     if {![info exists name]} { set name $token }
  395.     # add any registered items and make the menu contents
  396.     if {[info exists menu::additions($token)]} {
  397.     foreach ins [set menu::additions($token)] {
  398.         set where [lindex $ins 1]
  399.         set type [lindex $ins 0]
  400.         set ins [lrange $ins 2 end]
  401.         switch -- $type {
  402.         "submenu" {
  403.             lappend msubs [lindex $ins 0]
  404.             set ins [list [list Menu -n [lindex $ins 0] {}]]
  405.         }
  406.         }
  407.         switch -- [lindex $where 0] {
  408.         "replace" {
  409.             set old [lindex $where 1]
  410.             if {[set ix [eval llindex ma $old]] != -1} {
  411.             set ma [eval [list lreplace $ma $ix [expr {$ix -1 + [llength $old]}]] $ins]
  412.             } else {
  413.             alertnote "Bad menu::replacement registered '$old'"
  414.             }
  415.             
  416.         }
  417.         "end" {
  418.             eval lappend ma $ins
  419.         }
  420.         default {
  421.             set ma [eval linsert [list $ma] $where $ins]
  422.         }
  423.         }
  424.     }
  425.     }
  426.     # These two lines removed due to some conflicts
  427.     #    regsub -all {"?\(-"?([ \t\r\n]+"?\(-"?)+} $ma "(-" ma
  428.     #    regsub -all {(^[ \t\r\n]*"?\(-"?|"?\(-"?[ \t\r\n]*$)} $ma "" ma
  429.  
  430.     # backwards compatibility fix.  Removed because it's inefficient,
  431.     # and it's about time people used the new Menu command ;-)
  432.     # regsub -all "\{menu " $ma "\{Menu " ma
  433.  
  434.     # build the menu
  435.     set name [list -n $name]
  436.     if {[info exists theotherflags]} {
  437.     set name [concat $theotherflags $name]
  438.     }
  439.     if {[info tclversion] >= 8.0} {
  440.     lappend name -h [list "This is the [lindex $name end] menu"]
  441.     }
  442.     if {[info exists mproc]} {
  443.     if {$mproc != ""} {
  444.         eval Menu $name -p $mproc [list $ma]
  445.     } else {
  446.         eval Menu $name [list $ma]
  447.     }
  448.     } else {
  449.     eval Menu $name -p menu::generalProc [list $ma]
  450.     }
  451.     if {[info exists msubs]} {
  452.     return $msubs
  453.     }
  454.     return ""
  455. }
  456.  
  457. proc menu::replaceRebuild {name title} {
  458.     global $name
  459.     catch {removeMenu [set $name]}
  460.     set $name $title
  461.     menu::buildSome $name
  462.     insertMenu [set $name]
  463. }
  464.  
  465. proc menu::packagesBuild {} {
  466.     global alpha::package_menus package::prefs
  467.     lappend ma [menu::itemWithIcon "packagePreferences" 84] \
  468.       "miscellaneousPackages…"
  469.     if {[info exists package::prefs]} {
  470.     foreach pkg ${package::prefs} {
  471.         lappend ma "${pkg}Prefs…"
  472.     }
  473.     }
  474.     lappend ma "(-" "describeAPackage…" "readHelpForAPackage…" \
  475.       "uninstallSomePackages…" \
  476.       {Menu -m -n internetUpdates -p package::menuProc {}} \
  477.       "(-" "rebuildPackageIndices"
  478.     return [list build $ma menu::packagesProc]
  479. }
  480.  
  481. proc menu::packagesProc {menu item} {
  482.     global package::prefs
  483.     if {[regexp "(.*)Prefs" $item d pkg]} {
  484.     if {[lcontains package::prefs $pkg]} {
  485.         dialog::pkg_options $pkg
  486.         return
  487.     }
  488.     }
  489.     switch -- $item {
  490.     "miscellaneousPackages" {
  491.         return [dialog::preferences $menu Packages]
  492.     }
  493.     "describeAPackage" -
  494.     "Describe A Package" {
  495.         set pkg [dialog::optionMenu "Describe which package?" \
  496.           [lsort -ignore [alpha::package names]]]
  497.         package::describe $pkg
  498.     }
  499.     "readHelpForAPackage" -
  500.     "Read Help For A Package" {
  501.         set pkg [dialog::optionMenu "Read help for which package?" \
  502.           [lsort -ignore [alpha::package names]]]
  503.         package::helpFile $pkg
  504.     }
  505.     "uninstallSomePackages" -
  506.     "Uninstall Some Packages" {
  507.         package::uninstall
  508.     }
  509.     "rebuildPackageIndex" {
  510.         alpha::rebuildPackageIndices
  511.     }
  512.     "packagePreferences" {
  513.         alertnote "Select a package from the group below in the menu to\
  514.           edit its preferences."
  515.     }
  516.     default {
  517.         menu::generalProc global $item
  518.     }
  519.     }
  520. }
  521.  
  522.  
  523. proc menu::menuPackages {menu m} {
  524.     if {[package::helpOrDescribe $m]} {
  525.     return
  526.     }
  527.     # toggle global existence of '$m' menu
  528.     global global::menus modifiedVars
  529.     if {[set idx [lsearch  ${global::menus} $m]] == -1} {
  530.     lappend global::menus $m
  531.     global $m
  532.     catch $m
  533.     insertMenu [set    $m]
  534.     markMenuItem packageMenus $m 1
  535.     } else {
  536.     set global::menus [lreplace ${global::menus} $idx $idx]
  537.     global $m
  538.     catch "removeMenu [set $m]"
  539.     markMenuItem packageMenus $m 0
  540.     }
  541.     lappend modifiedVars global::menus
  542. }
  543.  
  544. if {[info tclversion] < 8.0} {
  545.     proc menu::modeBuild {} {
  546.     set ma [list "/p<BmenusAndFeatures…" "/ppreferences…" "editPrefsFile" \
  547.       "loadPrefsFile…" "describeMode" "(-" "/m<UchangeMode…"]
  548.     return [list build $ma mode::menuProc "" "Mode Prefs"]
  549.     }
  550. } else {
  551.     proc menu::modeBuild {} {
  552.     global mode
  553.     set ma [list "/p<BmenusAndFeatures…" "/ppreferences…" "editPrefsFile" \
  554.       "loadPrefsFile…" "describeMode" "(-" "/m<UchangeMode…"]
  555.     if {$mode != ""} {
  556.         return [list build $ma mode::menuProc "" "${mode} Mode Prefs"]
  557.     } else {
  558.         return [list build $ma mode::menuProc "" "Mode Prefs"]
  559.     }
  560.     }
  561. }
  562.  
  563. proc menu::preferencesBuild {} {
  564.     global flagPrefs
  565.     
  566.     set ma [list "/p<U<BMenus And Features…" "/p<USuffix Mappings…" \
  567.       "Edit Prefs File" "(-" [menu::itemWithIcon "Interface Preferences" 84]]
  568.     lappend ma Appearance Electrics Text Tiling Window "(-" \
  569.       [menu::itemWithIcon "Input-Output Preferences" 84]
  570.     lappend ma Backups Files Printer Tags WWW "(-" \
  571.       [menu::itemWithIcon "System Preferences" 84]
  572.     eval lunion ma [lsort [lremove [array names flagPrefs] Packages]]
  573.     return [list build $ma {dialog::preferences -m}]
  574. }
  575.  
  576. proc menu::removeFrom {name args} {
  577.     global menu::additions alpha::noMenusYet
  578.     if {[info exists menu::additions($name)]} {
  579.     if {[set i [lsearch -exact [set menu::additions($name)] $args]] != -1} {
  580.         set menu::additions($name) [lreplace [set menu::additions($name)] $i $i]
  581.         if {![info exists alpha::noMenusYet]} {
  582.         # we were called after start-up; build the menu now
  583.         menu::buildSome $name
  584.         }
  585.     }
  586.     }
  587. }
  588.  
  589. proc menu::replaceWith {name current type args} {
  590.     global menu::additions alpha::noMenusYet
  591.     if {![info exists menu::additions($name)]} {
  592.     lappend menu::additions($name) [concat [list $type [list replace $current]] $args]
  593.     } else {
  594.     set add 1
  595.     set j 0
  596.     foreach i [set menu::additions($name)] {
  597.         if {[lrange $i 0 1] == [list $type [list replace $current]]} {
  598.         if {[lindex $i 1] != $args} {
  599.             set add 0
  600.             set menu::additions($name) \
  601.               [lreplace [set menu::additions($name)] $j $j \
  602.               [concat [list $type [list replace $current]] $args]]
  603.             break
  604.         } else {
  605.             # no change
  606.             return
  607.         }
  608.         }
  609.         incr j
  610.     }
  611.     if {$add} {
  612.         lappend menu::additions($name) [concat [list $type [list replace $current]] $args]
  613.     }
  614.     }
  615.     if {![info exists alpha::noMenusYet]} {
  616.     # we were called after start-up; build the menu now
  617.     menu::buildSome $name
  618.     }
  619. }
  620.  
  621. proc menu::itemWithIcon {name icon} {
  622.     return "/\x1e${name}^[text::Ascii $icon 1]"
  623. }
  624.  
  625. proc file::open {} {findFile}
  626. proc file::close {} {killWindow}
  627.  
  628.  
  629. ## 
  630.  # -------------------------------------------------------------------------
  631.  # 
  632.  # "menu::generalProc" --
  633.  # 
  634.  #  If either 'item' or 'menu::item' exists, call it.  Else try and
  635.  #  autoload 'item', if that fails try and autoload 'menu::item'
  636.  # -------------------------------------------------------------------------
  637.  ##
  638. if {[info tclversion] < 8.0} {
  639.     proc menu::generalProc {menu item {lower 1}} {
  640.     if {$lower} {set menu [string tolower $menu]}
  641.     if {[info commands ${menu}::${item}] != ""} {
  642.         uplevel \#0 ${menu}::$item
  643.     } elseif {[info commands $item] != ""} {
  644.         uplevel \#0 $item
  645.     } elseif {[auto_load ${menu}::$item]} {
  646.         uplevel \#0 ${menu}::$item
  647.     } else {
  648.         uplevel \#0 $item
  649.     }
  650.     }
  651. } else {
  652.     proc menu::generalProc {menu item {lower 1}} {
  653.     if {$lower} {set menu [string tolower $menu]}
  654.     if {[info commands ::${menu}::${item}] != ""} {
  655.         uplevel \#0 ::${menu}::$item
  656.     } elseif {[info commands $item] != ""} {
  657.         uplevel \#0 $item
  658.     } elseif {[auto_load ::${menu}::$item]} {
  659.         uplevel \#0 ::${menu}::$item
  660.     } else {
  661.         uplevel \#0 $item
  662.     }
  663.     }
  664. }
  665.  
  666. proc menu::globalProc {menu item} {
  667.     menu::generalProc global $item
  668. }
  669.  
  670. proc menu::winProc {menu name} {
  671.     global winNameToNum
  672.  
  673.     set nms [array names winNameToNum]
  674.  
  675.     if {[lsearch $nms "*[quote::Find $name]"] < 0} {
  676.         $name
  677.         return
  678.     }
  679.  
  680.     foreach nm $nms {
  681.         if {[string match *[quote::Find $name] $nm] == "1"}  {
  682.             bringToFront $name
  683.             if {[icon -q]} { icon -f $name -o }
  684.             return
  685.         }
  686.     }
  687.     return "normal"
  688. }
  689.  
  690.  
  691. ## 
  692.  # proc namedClipMenuProc {menu item} {
  693.  #     switch $item {
  694.  #         "copy"      "copyNamedClipboard"
  695.  #         "cut"       "cutNamedClipboard"
  696.  #         "paste"     "pasteNamedClipboard"
  697.  #     }
  698.  # }
  699.  ##
  700.  
  701. proc menu::colorProc {menu item} {
  702.     global colorInds modifiedArrVars
  703.     if {[info exists colorInds($item)]} {
  704.     set color [eval [list colorTriple "New \"$item\":"] $colorInds($item)]
  705.     } else {
  706.     switch -- $item {
  707.         foreground    { set inds "0 0 0" }
  708.         background    { set inds "65535 65535 65535" }
  709.         blue        { set inds "0 0 65535" }
  710.         cyan        { set inds "61404 11464 34250" }
  711.         green        { set inds "1151 33551 8297" }
  712.         magenta        { set inds "44790 1591 51333" }
  713.         red            { set inds "65535 0 0" }
  714.         white        { set inds "65535 65535 65535" }
  715.         yellow        { set inds "61834 64156 12512" }
  716.         default        { set inds "65535 65535 65535" }
  717.     }
  718.     set color [eval [list colorTriple "New \"$item\":"] $inds]
  719.     }
  720.     eval setRGB $item $color
  721.     
  722.     set colorInds($item) $color
  723.     alpha::makeColourList
  724.     lappend modifiedArrVars colorInds
  725. }
  726.  
  727. proc alpha::makeColourList {} {
  728.     global alpha::colors colorInds alpha::basiccolors
  729.     # Set up color indices
  730.     foreach ind [array names colorInds] {
  731.     eval setRGB $ind $colorInds($ind)
  732.     }
  733.     set alpha::basiccolors {none blue cyan green magenta red white yellow}
  734.     set alpha::colors ${alpha::basiccolors}
  735.     foreach c {color_9 color_10 color_11 color_12 color_13 color_14 color_15} {
  736.     if {[info exists colorInds($c)]} {lappend alpha::colors $c}
  737.     }
  738. }
  739.  
  740.  
  741.         
  742. #===============================================================================
  743. proc helpMenu {item} {
  744.     global HOME
  745.     edit -r -c [file join $HOME Help $item]
  746. }
  747.  
  748. ## 
  749.  # -------------------------------------------------------------------------
  750.  # 
  751.  # "alphaHelp" --
  752.  # 
  753.  #  Called from about box
  754.  # -------------------------------------------------------------------------
  755.  ##
  756. proc alphaHelp {} {
  757.     global HOME
  758.     if {[file exists [set f [file join ${HOME} Help "Alpha Manual"]]]} {
  759.     edit -r -c $f
  760.     } else {
  761.     edit -r -c [file join $HOME Help "Quick Start"]
  762.     }
  763. }
  764.  
  765. proc register {} {
  766.     global HOME
  767.     launch -f [file join $HOME Register]
  768. }
  769.  
  770. namespace eval icon {}
  771. namespace eval file {}
  772.  
  773. proc icon::FromSig {sig} {
  774.     global alpha::_icons
  775.     if {[set p [lsearch -glob ${alpha::_icons} "${sig} *"]] != -1} {
  776.     set p [lindex ${alpha::_icons} $p]
  777.     return [lindex $p 2]
  778.     } else {
  779.     return ""
  780.     }
  781. }
  782.  
  783. proc icon::MenuFromSig {sig} {
  784.     global alpha::_icons
  785.     if {[set p [lsearch -glob ${alpha::_icons} "${sig} *"]] != -1} {
  786.     set char [expr {[lindex [lindex ${alpha::_icons} $p] 2] -208}]
  787.     if {$char < 1 || $char > 256} { return "" }
  788.     return "^[text::Ascii $char 1]"
  789.     } else {
  790.     return ""
  791.     }
  792. }
  793.  
  794.  
  795. proc menu::fileUtils {menu item} {
  796.     if {[lsearch -exact {"insertPathName" "insertFile" "fileRemove" "fileInfo" "wordCount" "textToAlpha"} $item] != -1} {return [$item]}
  797.     switch -- $menu {
  798.     "moreUtils" {
  799.         file::Utils::$item
  800.     }
  801.     default {
  802.         file::$item
  803.     }
  804.     }
  805. }
  806.  
  807. proc menu::winTileProc {menu item} {
  808.     win$item
  809. }
  810.  
  811. ## 
  812.  # -------------------------------------------------------------------------
  813.  # 
  814.  #    "menu::buildHierarchy" --
  815.  # 
  816.  #  Given a list of folders, 'menu::buildHierarchy' returns a hierarchical
  817.  #  menu based on the files and subfolders in each of these folders. 
  818.  #  Pathnames are optionally stored in a global array given by the argument
  819.  #  'filePaths'.  The path's index in this array is formed by concatenating
  820.  #  the submenu name and the filename, allowing the pathname to be
  821.  #  retrieved by the procedure 'proc' when the menu item is selected.
  822.  # 
  823.  #  The search may be restricted to files with specific extensions, or
  824.  #  files matching a certain pattern.  A search depth may also be given,
  825.  #  with three levels of subfolders assumed by default.
  826.  # 
  827.  #  See MacPerl.tcl or latexMenu.tcl for examples.
  828.  # 
  829.  #  (originally written by Tom Pollard, with modifications by Vince Darley
  830.  #  and Tom Scavo)
  831.  # 
  832.  # --Version--Author------------------Changes-------------------------------
  833.  #      1.0      Tom Pollard                    original
  834.  #      2.0      <vince@das.harvard.edu> multiple extensions, optional    paths
  835.  #      2.1      Tom Scavo                        multiple folders
  836.  #      2.2      <vince@das.harvard.edu> pattern matching as well as exts
  837.  #      2.3      <vince@das.harvard.edu> handles unique menu-names and does text only
  838.  #      2.4      <jl@theophys.kth.se>    now also handles patterns like "*.{a,b}"
  839.  # -------------------------------------------------------------------------
  840.  ##
  841. proc menu::buildHierarchy {folders name proc {filePaths {}} {exts *} {depth 3} {fset {}}} {
  842.     global filesetmodeVars file::separator
  843.     if { $filePaths != "" } {
  844.     global $filePaths
  845.     }
  846.     if {[llength $exts] > 1} {
  847.     regsub -all {\.} $exts "" exts
  848.     set exts "*.{[join $exts ,]}"
  849.     } elseif {[string match ".*" $exts] && ![string match {*\**} $exts]} {set exts "*$exts"}
  850.     incr depth -1
  851.     set overallMenu {}
  852.     foreach folder $folders {
  853.     if {[file exists $folder]} {
  854.         if {![file isdirectory $folder]} {
  855.         set folder "[file dirname $folder]${file::separator}"
  856.         }
  857.         if {![regexp -- "${file::separator}$" $folder]} {
  858.         set folder "$folder${file::separator}"
  859.         }
  860.         if {$name == 0} {
  861.         set name [file tail [file dirname ${folder}dummy]]
  862.         }
  863.         # if it's a fileset, we register _before_ recursing
  864.         if { $fset != "" } {
  865.         set mname [registerFilesetMenuName $fset $name $proc]
  866.         } else {
  867.         set mname $name
  868.         }
  869.         set menu {}
  870.         set subfolders [glob -nocomplain ${folder}*${file::separator}]
  871.         if {$filesetmodeVars(includeNonTextFiles)} {
  872.         set filenames [glob -nocomplain ${folder}$exts]
  873.         } else {
  874.         set filenames [glob -t TEXT -nocomplain ${folder}$exts]
  875.         }
  876.         # Note that the list of filenames may also contain some/all
  877.         # subfolders (if they matched the glob expression), hence
  878.         # we must be sure not to add them twice.
  879.         foreach m [lsort -ignore [concat $subfolders $filenames]] {
  880.         if {[set s [lsearch -exact $subfolders $m]] != -1 && $depth > 0} {
  881.             set subM [menu::buildHierarchy [list ${m}] 0 $proc $filePaths $exts $depth $fset]
  882.             if {[llength $subM]} { lappend menu $subM }
  883.         } elseif {[file isfile $m]} {
  884.             lappend menu [set fname [file tail $m]]
  885.             if { $filePaths != "" } {
  886.             set ${filePaths}([file join $name $fname]) $m
  887.             }
  888.         }
  889.         }
  890.         
  891.         if {[llength $menu]} {
  892.         set overallMenu [concat $overallMenu $menu]
  893.         }
  894.     } else {
  895.         beep
  896.         alertnote "menu::buildHierarchy:  Folder $folder does not exist!"
  897.     }
  898.     }
  899.     
  900.     if {[llength $overallMenu]} {
  901.     if { [string length $proc] > 1 } {
  902.         set pproc "-p $proc"
  903.     } else {
  904.         set pproc ""
  905.     }    
  906.     if { $fset != "" } {
  907.         if { [string length $proc] > 1 } { set pproc "-p subMenuProc" }
  908.     }     
  909.     return [concat {Menu -m -n} [list $mname] $pproc [list $overallMenu]]
  910.     
  911.     } else {
  912.     return ""
  913.     }
  914. }
  915.  
  916. # in case we've done something odd elsewhere
  917. ensureset filesetmodeVars(includeNonTextFiles) 0
  918.  
  919.  
  920. proc menu::reinterpretOldMenu {args} {
  921.     set ma [lindex $args end]
  922.     set args [lreplace $args end end]
  923.     getOpts {-n -M -p}
  924.     if {[info exists opts(-p)]} {
  925.     lappend proc $opts(-p)
  926.     } else {
  927.     lappend proc "-1"
  928.     }
  929.     if {[info exists opts(-M)]} { lappend proc -M $opts(-m) }
  930.     if {[info exists opts(-m)]} { lappend proc -m }
  931.     menu::buildOne $opts(-n) build $ma $proc
  932. }
  933.  
  934.  
  935.  
  936.  
  937.